home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istsa / ISTSA.MAC.f next >
Encoding:
Text File  |  1989-03-04  |  9.4 KB  |  268 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.4
  3. C---------------------------------------------------------
  4. C YXLIB Customisation Parameters
  5. C ------------------------------
  6.  
  7. C Routine Names
  8. C -------------
  9.  
  10. C Field Definitions: Parse Tree Attributes
  11. C ----------------------------------------
  12. C Note: The high-order bit in the word (bit 31 in a 32-bit machine) MUST
  13. C       NOT BE USED, as ordinary arithmetic is used to extract some fields
  14.  
  15. C Attribute Table Macros
  16. C ----------------------
  17.  
  18. C YXLIB Bits
  19. C ----------
  20.  
  21. C YXLIB Local Record Macros
  22. C -------------------------
  23. C   type VARX = record
  24. C                   su: integer;    (* Storage units for variable *)
  25. C                   common: ^(S_COMMON) or -maxint..-1;
  26. C                                   (* ^(common block symbol), nil (0) or
  27. C                                      negative of equivalence class number *)
  28. C                   comsize: integer;(* Offset in common or equiv class *)
  29. C                   equiv: ^EQV;    (* Pointer to equivalence link *)
  30. C                   if SYMBOL(var_arr_decl)<>0 then array: ARRAYX
  31. C                                   (* array information stored here *)
  32. C               end;
  33. C
  34. C   type ARRAYX = record
  35. C                   elts: integer;  (* Number of elements in the array *)
  36. C                   dims: integer;  (* Number of dimensions of the array *)
  37. C                   limits: array [1..dims] of
  38. C                               record LOWER,UPPER: integer end
  39. C                 end;
  40.  
  41.  
  42. C   type EQH = HEAD record          (* Equivalence head record *)
  43. C                       common: ^(S_COMMON) or -maxint..-1;
  44. C                       usage: set of usage_bits
  45. C                   end;
  46.  
  47. C   type EQV = LINK record          (* Equivalence variable record (link) *)
  48. C                       sudif: integer;
  49. C                       symbol: ^(S_VAR)
  50. C                   end;
  51.  
  52. C   type LPR = record
  53. C                   glob: ^(GPU) or -^(GEX);
  54. C                   nargs: integer;
  55. C                   args: array [1..nargs] of packed record
  56. C                               dtype: min_dtype..max_dtype;
  57. C                               argument_type: atype;
  58. C                               descendents: ^HEAD;
  59. C                               if dtype=type_char then
  60. C                                   min_length, max_length: integer
  61. C                               end if
  62. C                           end record
  63. C              end;
  64.  
  65. C                                   (* Argument type definitions *)
  66. C   type ATYPE = (scalar,arelm,array,proc,label);
  67. C   const min_atype = scalar; max_atype = label;
  68.  
  69. C YXLIB Record Definition: Semi-Local
  70. C -----------------------------------
  71. C   type PAREC = LINK record
  72. C                   argnum: integer; (* Argument number passed down as *)
  73. C                   prsym: ^(S_PROC); (* Procedure passed down to *)
  74. C                   argsym: ^symbol; (* Actual argument being passed down *)
  75. C                   pusym: ^(S_PU); (* Associating program-unit (context) *)
  76. C                   stmtno: integer; (* Statement number of assoc (context) *)
  77. C                end;
  78.  
  79. C   type UNSAF = LINK record
  80. C                   code: 1..5;     (* Type of unsafe reference to be checked *)
  81. C                   argnum: integer;(* Argument number applicable *)
  82. C                   extra: anything;(* Extra data (not used by inherit_expr) *)
  83. C                   pusym: ^(S_PU); (* Context: associating program-unit *)
  84. C                   stmtno: integer;(* Context: statement number *)
  85. C                   prsym: ^(S_PROC)(* proc being called *)
  86. C                end;
  87.  
  88. C YXLIB Global Record Macros
  89. C --------------------------
  90. C
  91. C   type G_COM = record             Global common block record
  92. C                   size: integer;
  93. C                   type: (character,numeric,mixed); (* logical = numeric *)
  94. C                   save: (saved,not_saved,only_in_main);
  95. C                   init: integer   (* Number of times init'ed by block data *)
  96. C                end;
  97.  
  98. C
  99. C   type G_PU = record              Global program-unit record
  100. C                   dtype: integer;
  101. C                   chrlen: integer;
  102. C                   culist: ^HEAD;  (* common block usage list header ptr *)
  103. C                   nargs: integer;
  104. C                   descend: ^HEAD; (* descendent routine list header ptr *)
  105. C                   entrys: ^(HEAD) record ^G_ENT end;
  106. C                   args: array [1..nargs] of gpuarg
  107. C               end;
  108.  
  109. C   type G_ENT = record
  110. C                   dtype: integer;
  111. C                   chrlen: integer;
  112. C                   pu: ^G_PU;
  113. C                   nargs: integer;
  114. C                   descend: ^HEAD; (* descendent routine list header ptr *)
  115. C                   args: array [1..nargs] of ^guparg
  116. C                end;
  117.  
  118. C type gpuarg = record
  119. C                   dtype,chlen: integer;
  120. C                   usage: (arg,read,update);
  121. C                   struc: (scal,array,proc,label);
  122. C                   size: integer;
  123. C                   pass: ^HEAD;
  124. C                   inh: ^HEAD(inherit)
  125. C               end;
  126. C type inherit = record
  127. C                   type: (proc,expr,dupl,comm,sfa,doix,arg);
  128. C                   ass: ^(GPU);    (* associating program-unit *)
  129. C                   snum: integer;  (* statement number of association *)
  130. C                   if (type=proc) then
  131. C                       gsyptr: ^(GPU)/-^(GEX)
  132. C                   else
  133. C                       extra: integer (* unsafe ref extra data *)
  134. C                   end if
  135.  
  136.  
  137. C Global Descendant Routine Types
  138. C -------------------------------
  139.  
  140. C Error Codes returned by YXLIB
  141. C -----------------------------
  142. C ======================================================================
  143. C
  144. C       I S T S A   -   Main program for Toolpack/1 Semantic Analyser
  145. C
  146. C ======================================================================
  147.  
  148.         PROGRAM ISTSA
  149.  
  150.         INTEGER PATHL
  151.         PARAMETER (PATHL=81+1)
  152.  
  153.         INTEGER TREPTH(PATHL),SYMPTH(PATHL),MTRPTH(PATHL),
  154.      +          MSYPTH(PATHL),ATRPTH(PATHL)
  155.  
  156.         INTEGER IODTRE,IODSYM,IODATR,NERROR,NWARN
  157.         LOGICAL REWTRE,REWSYM
  158.  
  159.         INTEGER GETARG,OPEN,CREATE
  160.         EXTERNAL ZINIT,GETARG,ZQUIT,ZYINPT,ZYINSY,CLOSE,OPEN,CREATE,
  161.      +           ZYXZIA,ZYXOAS,ZYSOUT,ZMESS
  162.  
  163.         CALL ZINIT
  164.  
  165.         CALL ZMESS('ISTSA - Toolpack Semantic Analyser, Version 1..1',
  166.      +             1)
  167.  
  168.         IF (GETARG(1,TREPTH,81).EQ.-100) CALL NAMES(TREPTH,1)
  169.         IF (GETARG(2,SYMPTH,81).EQ.-100) CALL NAMES(SYMPTH,2)
  170.         IF (GETARG(3,MTRPTH,81).EQ.-100) CALL NAMES(MTRPTH,3)
  171.         IF (GETARG(4,MSYPTH,81).EQ.-100) CALL NAMES(MSYPTH,4)
  172.         IF (GETARG(5,ATRPTH,81).EQ.-100) CALL NAMES(ATRPTH,5)
  173.  
  174.         NERROR=0
  175.         NWARN=0
  176.  
  177.         IODTRE=OPEN(TREPTH,0)
  178.         IF (IODTRE.EQ.-1) CALL ERROR('Can''t open parse tree')
  179.         IODSYM=OPEN(SYMPTH,0)
  180.         IF (IODSYM.EQ.-1) CALL ERROR('Can''t open symbol table')
  181.         IODATR=CREATE(ATRPTH,1)
  182.         IF (IODATR.EQ.-1) CALL ERROR('Can''t create attribute file')
  183.  
  184.         REWTRE=MTRPTH(1).EQ.129
  185.         REWSYM=MSYPTH(1).EQ.129
  186.         IF (MTRPTH(1).EQ.45) REWTRE=MTRPTH(2).EQ.129
  187.         IF (MSYPTH(1).EQ.45) REWSYM=MSYPTH(2).EQ.129
  188.  
  189.         CALL ZYINPT(IODTRE)
  190.         CALL CLOSE(IODTRE)
  191.         CALL ZYINSY(IODSYM)
  192.         CALL CLOSE(IODSYM)
  193.         CALL ZYXZIA
  194.  
  195.         CALL ANALYS(.TRUE.,NERROR,NWARN)
  196.  
  197.         IF (NERROR.GT.0) THEN
  198.             CALL ZMESS('[ISTSA Terminated, Errors detected]',2)
  199.             CALL ZQUIT(-1)
  200.         ELSE
  201.             IF (REWTRE) THEN
  202.                 IODTRE=CREATE(TREPTH,1)
  203.             ELSE
  204.                 IODTRE=CREATE(MTRPTH,1)
  205.             END IF
  206.             IF (IODTRE.EQ.-1) CALL ERROR('Can''t create modified tree')
  207.             CALL ZYTOUT(IODTRE)
  208.             IF (REWSYM) THEN
  209.                 IODSYM=CREATE(SYMPTH,1)
  210.             ELSE
  211.                 IODSYM=CREATE(MSYPTH,1)
  212.             END IF
  213.             IF (IODSYM.EQ.-1)
  214.      +          CALL ERROR('Can''t create modified symbol table')
  215.             CALL ZYSOUT(IODSYM)
  216.             CALL ZYXOAS(IODATR)
  217.             IF (NWARN.GT.0) THEN
  218.                 CALL ZMESS('[ISTSA Terminated, Warnings produced]',2)
  219.                 CALL ZQUIT(-1002)
  220.             ELSE
  221.                 CALL ZMESS('[ISTSA Normal Termination]',2)
  222.                 CALL ZQUIT(-2)
  223.             END IF
  224.         END IF
  225.  
  226.         END
  227. C ----------------------------------------------------------------------
  228. C
  229. C       N A M E S   -   Prompt user for filenames
  230. C
  231.  
  232.         SUBROUTINE NAMES(PATH,NUMBER)
  233.         INTEGER PATH(*),NUMBER
  234.  
  235.         INTEGER PROMPT(24,5),I
  236.  
  237.         SAVE PROMPT
  238.  
  239.         INTEGER ZGTCMD
  240.         EXTERNAL ZGTCMD,ZPRMPT,ERROR
  241.  
  242. C "Input parse tree: "
  243. C "Input symbol table: "
  244. C "Modified parse tree: "
  245. C "Modified symbol table: "
  246. C "Attribute file: "
  247.  
  248.         DATA (PROMPT(I,1),I=1,19)/73,110,112,117,116,32,112,
  249.      +97,114,115,101,32,116,114,101,101,58,32,129/,
  250.      +       (PROMPT(I,2),I=1,21)/73,110,112,117,116,32,115,
  251.      +121,109,98,111,108,32,116,97,98,108,101,58,
  252.      +32,129/,
  253.      +       (PROMPT(I,3),I=1,22)/77,111,100,105,102,105,101,
  254.      +100,32,112,97,114,115,101,32,116,114,101,101,
  255.      +58,32,129/,
  256.      +       (PROMPT(I,4),I=1,24)/77,111,100,105,102,105,101,
  257.      +100,32,115,121,109,98,111,108,32,116,97,98,
  258.      +108,101,58,32,129/,
  259.      +       (PROMPT(I,5),I=1,17)/65,116,116,114,105,98,117,
  260.      +116,101,32,102,105,108,101,58,32,129/
  261.  
  262.         CALL ZPRMPT(PROMPT(1,NUMBER))
  263.         IF (ZGTCMD(PATH,0).EQ.-1)
  264.      +      CALL ERROR('ZGTCMD returned Error status')
  265.  
  266.         END
  267.  
  268.